

module TestSuite (main) where

import MainHelp
import Structures
import Data.Char
import System.FilePath.Posix
import System.Environment (getArgs)
import System.Exit (exitFailure, exitSuccess)
import System.Directory
import Control.Monad
import System.IO
import PGF

main :: IO ()
main = do args <- getArgs
          let (b,maybeFile) = checkArgs args
          case maybeFile of
             Just filePath -> do
                runFile b filePath
                exitSuccess
             Nothing      -> do
                hSetBuffering stdin NoBuffering
                hSetBuffering stdout NoBuffering
                hSetEcho stdin False
                let path = "../examples/testsuite/"
                allFiles <- getDirectoryContents path
                let txtFiles = map (path ++) $ filter (( ==".txt") . takeExtension) allFiles
                mapM_ (chooseFile b) txtFiles
                hSetEcho stdin True
                exitSuccess
            --_          -> do putStrLn "Usage: runghc TestSuite [-v] [filePath]"
            --                 exitFailure

chooseFile :: Bool -> FilePath -> IO ()
chooseFile b filePath = do
   putStr $ "Solve syllogisms in " ++ (takeFileName filePath) ++ "? (y/n) "
   ans <- getChar
   case ans of
      'y' -> putStrLn "" >> runFile b filePath
      'n' -> putStrLn "" >> return ()
      _   -> putStrLn "\nInvalid answer, please answer 'y' or 'n'" >>
             chooseFile b filePath 

runFile :: Bool -> FilePath -> IO ()
runFile b filePath = do
        fileContent <- readFile filePath
        let sLang = "Syllogism" ++ drop (length "Language: ") (head $ lines fileContent)
        let lang = case readLanguage sLang of
                    Just l  -> l
                    Nothing -> error $ "No language " ++ sLang                     
        let allLines = tail $ lines fileContent
        let syllogisms = filter ((/= '-') . head . snd) $ filter (not . null . snd) (zip [2..] allLines)
        putStrLn $ "Testing syllogisms in: " ++ takeFileName filePath
        bs <- mapM (solveSyllogism b lang) syllogisms
        putStrLn $ show (length (filter (==True) bs)) ++ " of " ++ show (length bs) ++ " syllogims passed"

checkArgs :: [String] -> (Bool, Maybe FilePath)
checkArgs = (flip checkArgs') (False, Nothing)

checkArgs' :: [String] -> (Bool, Maybe FilePath) -> (Bool, Maybe FilePath)
checkArgs' [] r            = r
checkArgs' ("-v":xs) (_,f) = checkArgs' xs (True,f)
checkArgs' (x:xs) (b,_)    = (b, Just x) 

solveSyllogism :: Bool -> Language -> (Int, String) -> IO Bool
solveSyllogism verbose lang (line,s) = do
   let sylType  = extractType s
   let syl      = extractSyllogism s
   let expected = extractAnswer s
   maybeReceived <- helpMain syl lang
   case maybeReceived of
      Nothing       -> showLine >> showSyl syl >> putStrLn "Unable to parse syllogism\n" >> return False
      Just received -> do
        let asExpected = expected == received
        let c = if asExpected then green else red
        when (verbose || not asExpected) $ showLine >> showSyl syl
                >> putStrLn ( "The expected answer was: " ++ color c (showAnswer expected) )
                >> putStrLn ( "The received answer was: " ++ color c (showAnswer received) ++ "\n" )  
        return asExpected
  where showLine    = putStrLn $ "Syllogism on line " ++ show line
        showSyl syl = putStr $ showSyllogism syl 

showSyllogism :: String -> String 
showSyllogism = 
   unlines . (\(a,b) -> 
      showSentences a ++ showConclusion b) . break (=="->") . filter (\x -> x /=")" && x /="(") . words

showSentences, showConclusion :: [String] -> [String]
showSentences  = map (('\t':) . firstToUpper . unwords) . splitAtPlus 
showConclusion = (:[]) . ('\t':) . firstToUpper . unwords . tail

firstToUpper (x:xs) = (toUpper x) : xs

splitAtPlus :: [String] -> [[String]]
splitAtPlus s =  case dropWhile (=="+") s of
             [] -> []
             s1 -> w : splitAtPlus s2
                   where (w, s2) = break (=="+") s1



toAnswer :: String -> Answer
toAnswer s = case filter (not. isSpace) s of
    "true"          -> ATrue
    "false"         -> AFalse
    "inconclusive"  -> AInconc
    "contradictory" -> AContr
    _               -> AMissing 

extractType :: String -> Maybe String
extractType s =
   if elem '#' s 
     then Just $ fst $ break (== '#') s
     else Nothing

extractAnswer :: String -> Answer
extractAnswer = toAnswer . tail . snd . break (== '|')

extractSyllogism :: String -> String
extractSyllogism s = 
    if elem '#' s
      then fst $ break (== '|') $ tail $ snd $ break (== '#') s
      else fst $ break (== '|') s

test = "( all cats are lovely + all lovely fly ) -> all cats fly"

-- Terminal color output, stolen from Compiler Construction testsuite 

type Color = Int

color :: Color -> String -> String
color c s = fgcol c ++ s ++ normal

normal = "\ESC[0m"

bold :: String -> String
bold = ("\ESC[1m" ++)


fgcol :: Int -> String
fgcol col = "\ESC[0" ++ show (30+col) ++ "m"


red, green, blue,pink :: Color
red = 1
green = 2
blue = 4
pink = 5
